home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / b / b.lha / B / src / bint / b3typ.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-11-24  |  2.8 KB  |  110 lines
  1. /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
  2.  
  3. /*
  4.   $Header: b3typ.c,v 1.4 85/08/22 16:59:46 timo Exp $
  5. */
  6.  
  7. /* Type matching */
  8. #include "b.h"
  9. #include "b1obj.h"
  10. #include "b3env.h"
  11. #include "b3sem.h"
  12. #include "b3typ.h"
  13.  
  14. #define Tnil ((btype) Vnil)
  15.  
  16. Forward btype valtype();
  17.  
  18. /* All the routines in this file are temporary */
  19. /* Thus length() has been put here too */
  20.  
  21. Visible int length(v) value v; {
  22.     value s= size(v);
  23.     int len= intval(s);
  24.     release(s);
  25.     return len;
  26. }
  27.  
  28. Visible btype loctype(l) loc l; {
  29.     value *ll;
  30.     if (Is_simploc(l)) {
  31.         simploc *sl= Simploc(l);
  32.         if (!in_env(sl->e->tab, sl->i, &ll)) return Tnil;
  33.         return valtype(*ll);
  34.     } else if (Is_tbseloc(l)) {
  35.         tbseloc *tl= Tbseloc(l);
  36.         btype tt= loctype(tl->R), associate;
  37.         if (tt == Tnil) return Tnil;
  38.         if (!empty(tt)) associate= th_of(one, tt);
  39.         else associate= Tnil;
  40.         release(tt);
  41.         return associate;
  42.     } else if (Is_trimloc(l)) {
  43.         return mk_text("");
  44.     } else if (Is_compound(l)) {
  45.         btype ct= mk_compound(Nfields(l)); intlet k, len= Nfields(l);
  46.         k_Overfields { *Field(ct, k)= loctype(*Field(l, k)); }
  47.         return ct;
  48.     } else {
  49.         syserr(MESS(4200, "loctype asked of non-target"));
  50.         return Tnil;
  51.     }
  52. }
  53.  
  54. Visible btype valtype(v) value v; {
  55.     if (Is_number(v)) return mk_integer(0);
  56.     else if (Is_text(v)) return mk_text("");
  57.     else if (Is_compound(v)) {
  58.         btype ct= mk_compound(Nfields(v)); intlet k, len= Nfields(v);
  59.         k_Overfields { *Field(ct, k)= valtype(*Field(v, k)); }
  60.         return ct;
  61.     } else if (Is_ELT(v)) {
  62.         return mk_elt();
  63.     } else if (Is_list(v)) {
  64.         btype tt= mk_elt(), vt, ve;
  65.         if (!empty(v)) {
  66.             insert(vt= valtype(ve= min1(v)), &tt);
  67.             release(vt); release(ve);
  68.         }
  69.         return tt;
  70.     } else if (Is_table(v)) {
  71.         btype tt= mk_elt(), vk, va;
  72.         if (!empty(v)) {
  73.             vk= valtype(*key(v, 0));
  74.             va= valtype(*assoc(v, 0));
  75.             replace(va, &tt, vk);
  76.             release(vk); release(va);
  77.         }
  78.         return tt;
  79.     } else {
  80.         syserr(MESS(4201, "valtype called with unknown type"));
  81.         return Tnil;
  82.     }
  83. }
  84.  
  85. Visible Procedure must_agree(t, u, m) btype t, u; int m; {
  86.     intlet k, len;
  87.     value vt, vu;
  88.     if (t == Tnil || u == Tnil || t == u) return;
  89.     if (Is_number(t) && Is_number(u)) return;
  90.     if (Is_text(t) && Is_text(u)) return;
  91.     if (Is_ELT(u) && (Is_ELT(t) || Is_list(t) || Is_table(t))) return;
  92.     if (Is_ELT(t) && (             Is_list(u) || Is_table(u))) return;
  93.     if (Is_compound(t) && Is_compound(u)) {
  94.         if ((len= Nfields(t)) != Nfields(u)) error(m);
  95.         else k_Overfields { must_agree(*Field(t,k), *Field(u,k), m); }
  96.     } else {
  97.         if (Is_list(t) && Is_list(u)) {
  98.             if (!empty(t) && !empty(u)) {
  99.                 must_agree(vt= min1(t), vu= min1(u), m);
  100.                 release(vt); release(vu);
  101.             }
  102.         } else if (Is_table(t) && Is_table(u)) {
  103.             if (!empty(t) && !empty(u)) {
  104.                 must_agree(*key(t, 0), *key(u, 0), m);
  105.                 must_agree(*assoc(t, 0), *assoc(u, 0), m);
  106.             }
  107.         } else error(m);
  108.     }
  109. }
  110.